COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY expred
C00006 ENDMK
C⊗;
ENTRY expred;
BEGIN "EXPRED"
REQUIRE "36A" COMPILER!SWITCHES;
REQUIRE "BUFDEC" SOURCE!FILE;
INTERNAL INTEGER PROCEDURE expred(INTEGER INBUF,FACTOR; reference integer varbuf);
    BEGIN "expred"
    INTEGER ROWNUM,COLNUM,NEWROW,NEWCOL,OUTBUF,ICOL,JCOL,KCOL,
	i,j,t,v,vptr,
    IROW,JROW,KROW,PTVAL,II,RSTOP,CSTOP,PTR1,PTR2;
    real inc,sum,p,nvar,newpt;
    safe real array distri[1:factor,1:factor];
    DEFINE !="COMMENT";
    simple internal real procedure fcn(real x);
	return(8*(2↑(-x)));

    inc←(factor+1.0)/2.0;
    sum←0.0;
    for i←1 thru factor do
	for j←1 thru factor do
	sum←sum+(distri[i,j]←fcn(sqrt((i-inc)↑2+(j-inc)↑2)));
    for i←1 thru factor do
	for j←1 thru factor do
	distri[i,j]←distri[i,j]/sum;
    NEWROW←(ROWNUM←ROWS(INBUF))/FACTOR;		! ROWS IN NEW PIX;
    NEWCOL←(COLNUM←COLMS(INBUF))/FACTOR;		! COLMS IN NEW PIX;
    GETBUF(NEWROW,NEWCOL,BYTSZ(INBUF),OUTBUF←fndbuf);		! create the buffers;
    GETBUF(NEWROW,NEWCOL,BYTSZ(INBUF),varbuf←fndbuf);

    !  THIS LOOP DOES IT;

	! INDEX THROUGH NEW PICTURE;
    FOR IROW←1 STEP 1 UNTIL NEWROW DO 
	BEGIN
	PTR1←OUTPTR(IROW,1,OUTBUF);
	vptr←outptr(irow,1,varbuf);
	JROW←1+(IROW-1)*FACTOR;		! START ROW OF SUB-MATRIX;
	RSTOP←JROW+FACTOR-1;		! LAST ROW OF SUB-M;
	FOR ICOL←1 STEP 1 UNTIL NEWCOL DO 
	    BEGIN
	    JCOL←1+(ICOL-1)*FACTOR;		! START COL OF SUB-MATRIX IN OLD PIX;
	    NEWPT←0;
	    i←1;
	    nvar←0.0;
	    CSTOP←JCOL+FACTOR-1;

	    ! THIS IS THE ACTUAL AVERAGING LOOP;
	    FOR KROW←JROW STEP 1 UNTIL RSTOP DO 
		BEGIN
		PTR2←INPTR(KROW,JCOL,INBUF);
		j←0;
		FOR KCOL←JCOL STEP 1 UNTIL CSTOP DO 
		    begin
		    NEWPT←NEWPT+(v←ILDB(PTR2))*(p←distri[i,j←j+1]);		! ADD THEM UP;
		    nvar←nvar+v*v*p;
		    end;
		i←i+1;
		END;
	    IDPB(t←NEWPT,PTR1);
	    idpb(t←nvar-newpt*newpt,vptr);
	    END;
	ROWCHK(CHKROW,ROWS,IROW,50);
	END;
    RETURN (OUTBUF);		! OUR RESULT IS THE NEW BUFFER;
    END "expred";
END "EXPRED";